home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / smaltalk / st80_r41.lha / st80_r41 / RestrictBrowsing.st < prev    next >
Text File  |  1993-07-23  |  7KB  |  193 lines
  1. "
  2.     NAME        RestrictBrowsing
  3.     AUTHOR        Carl McConnell <mcconnel@cs.uiuc.edu>
  4.     FUNCTION    Allows implementors, senders, etc. to be restricted to a set of categories 
  5.     ST-VERSIONS    R4.1
  6.     PREREQUISITES   none
  7.     DISTRIBUTION    world
  8.     VERSION ID    1.0
  9.     VERSION DATE    October 23, 1992
  10.  
  11. This code adds a 'restrict to ...' item to the Launcher 'Browsers' menu that allows 'implementors', 'senders', etc. to consider only categories matching the set of patterns you provide.  For example, giving the patterns 
  12.     Tools-* Magnitude-*
  13. will cause 'implementors of ...' and its relatives to only display methods in classes that are in categories whose names begin with 'Tools-' or 'Magnitude-'.  You can change things back to normal by giving the pattern
  14.     *
  15. The System Browser itself is unaffected: it displays all categories just as it always does.  It is only 'implementors', 'senders', etc. that act differently.  For example, the 'senders' menu item in the method pane of the browser will only find methods in categories matching the given patterns.
  16.  
  17. This file-in automatically starts up a new Launcher.
  18.  
  19. N.B.: before you decide a message is unused, you might want to change the browsing restriction back to '*' and re-check senders.
  20.  
  21. "!
  22.  
  23.  
  24. !LauncherView class methodsFor: 'private'!
  25.  
  26. browseMenu
  27.     "Answer a submenu of browsing items"
  28.     | keys subMenu |
  29.  
  30.     keys := 'system\class...\senders of...\implementors of...\class examples\restrict to ...' 
  31.                 withCRs asText allBold.
  32.     subMenu := PopUpMenu
  33.             labels: keys
  34.             lines: #(5)
  35.             values: (Array new: 6).
  36.     subMenu valueAt: 1 put: [Browser open].
  37.     subMenu valueAt: 2 put: [Browser newPickClass].
  38.     subMenu valueAt: 3 put: [Browser promptThenBrowseCalls].
  39.     subMenu valueAt: 4 put: [Browser promptThenBrowseImplementors].
  40.     subMenu valueAt: 5 put: [Browser browseAllClassExamples].
  41.     subMenu valueAt: 6 put: [Browser promptForBrowsingRestrictions].
  42.     ^subMenu! !
  43.  
  44. Model subclass: #Browser
  45.     instanceVariableNames: 'organization category className meta protocol selector textMode '
  46.     classVariableNames: 'CategoryMenu CategoryPatterns ClassMenu LastProtocol MessageMenu MethodMoveProtocol ProtocolMenu RemoveChangesOnFileOut TextMenu '
  47.     poolDictionaries: ''
  48.     category: 'Tools-Programming'!
  49.  
  50.  
  51. !Browser class methodsFor: 'class initialization'!
  52.  
  53. categoryPatterns
  54.     "Answer a space-separated list of string patterns representing 
  55.     the categories to which browsing is restricted."
  56.  
  57.     ^CategoryPatterns isNil
  58.         ifTrue: ['*']
  59.         ifFalse: [CategoryPatterns inject: '' into: [:soFar :this | soFar , this , ' ']]!
  60.  
  61. categoryPatterns: aString 
  62.     "Set the categories to which browsing is restricted according to 
  63.     the space-separated string patterns in the argument."
  64.  
  65.     | stream patterns |
  66.     CategoryPatterns := aString = '*'
  67.                 ifTrue: [nil]
  68.                 ifFalse: 
  69.                     [stream := aString readStream.
  70.                     patterns := OrderedCollection new.
  71.                     
  72.                     [stream skipSeparators.
  73.                     stream atEnd]
  74.                         whileFalse: [patterns add: (stream upTo: Character space)].
  75.                     patterns asArray]! !
  76.  
  77. !Browser class methodsFor: 'retrieving'!
  78.  
  79. allCallsOn: aLiteral 
  80.     "Answer a SortedCollection of all the methods that call on aLiteral."
  81.  
  82.     | aSortedCollection |
  83.     aSortedCollection := SortedCollection new.
  84.     Cursor execute showWhile: 
  85.         [self someBehaviorsDo: 
  86.             [:class |
  87.              (class whichSelectorsReferTo: aLiteral) do: 
  88.                 [:sel | aSortedCollection add: class name , ' ' , sel]]].
  89.     ^aSortedCollection!
  90.  
  91. allCallsOn: firstLiteral and: secondLiteral
  92.     "Answer a SortedCollection of all the methods that call on both aLiteral and
  93.     secondLiteral."
  94.  
  95.     | aCollection secondArray |
  96.     aCollection := SortedCollection new.
  97.     Cursor execute showWhile:
  98.         [self someBehaviorsDo:
  99.             [:class |
  100.             secondArray := class whichSelectorsReferTo: secondLiteral.
  101.             (class whichSelectorsReferTo: firstLiteral) do:
  102.                 [:sel | (secondArray includes: sel) ifTrue:
  103.                     [aCollection add: class name , ' ' , sel]]]].
  104.     ^aCollection!
  105.  
  106. allClassesImplementing: aSelector  
  107.     "Answer an Array of all classes that implement the message aSelector."
  108.  
  109.     | aCollection |
  110.     aCollection := ReadWriteStream on: Array new.
  111.     self someBehaviorsDo:
  112.         [:class | (class includesSelector: aSelector)
  113.             ifTrue: [aCollection nextPut: class]].
  114.     ^ aCollection contents!
  115.  
  116. allClassMethodsInProtocol: aProtocol
  117.  
  118.     "Answer a SortedCollection of all the class methods that appear in the protocol called aProtocol."
  119.  
  120.     | aCollection theProtocolSymbol |
  121.  
  122.     aCollection := SortedCollection new.
  123.     theProtocolSymbol := Symbol findInterned: aProtocol asString.
  124.     theProtocolSymbol isNil ifTrue: [^aCollection].
  125.     self someBehaviorsDo: [:class |
  126.         (class isMeta) ifTrue: [
  127.             (class organization listAtCategoryNamed: theProtocolSymbol) do: [:selector |
  128.                 aCollection add: class name, ' ', selector]]].
  129.     ^aCollection!
  130.  
  131. allImplementedMessages
  132.     "Answer a Set of all the messages that are
  133.     implemented by some class."
  134.  
  135.     | aSet |
  136.     aSet := Set new: (Symbol tableSize * 1.5) truncated.
  137.     Cursor execute showWhile: 
  138.         [self someBehaviorsDo: [:cl | aSet addAll: cl selectors]].
  139.     ^aSet!
  140.  
  141. allImplementorsOf: aSelector  
  142.     "Answer a SortedCollection of all the methods that implement the message aSelector."
  143.  
  144.     | aCollection |
  145.     aCollection := SortedCollection new.
  146.     Cursor execute showWhile:
  147.         [self someBehaviorsDo:
  148.             [:class |
  149.             (class includesSelector: aSelector)
  150.                 ifTrue: [aCollection add: class name, ' ', aSelector]]].
  151.     ^aCollection!
  152.  
  153. allSelect: aBlock 
  154.     "Answer a SortedCollection of each method that, when used as the
  155.     block argument to aBlock, gives a true result."
  156.  
  157.     | aCollection |
  158.     aCollection := SortedCollection new.
  159.     Cursor execute showWhile: 
  160.         [self someBehaviorsDo: 
  161.             [:class | class selectors do: 
  162.                 [:sel | (aBlock value: (class compiledMethodAt: sel))
  163.                     ifTrue: [aCollection add: class name , ' ' , sel]]]].
  164.     ^aCollection!
  165.  
  166. someBehaviorsDo: aBlock 
  167.     CategoryPatterns isNil
  168.         ifTrue: [Smalltalk allBehaviorsDo: aBlock]
  169.         ifFalse: [CategoryPatterns do: [:pattern | Smalltalk allBehaviorsIn: pattern do: aBlock]]! !
  170.  
  171. !Browser class methodsFor: 'browsing'!
  172.  
  173. promptForBrowsingRestrictions
  174.     | response |
  175.     response := DialogView request: 'Restrict browsing to what categories?' initialAnswer: self categoryPatterns.
  176.     response isEmpty ifTrue: [^self].
  177.     self categoryPatterns: response! !
  178.  
  179. !SystemDictionary methodsFor: 'enumerating'!
  180.  
  181. allBehaviorsIn: aPattern do: aBlock 
  182.     "Evaluate the block aBlock for each kind of Behavior (that 
  183.     is, Object and its subclasses) in any category matching the pattern string aPattern."
  184.  
  185.     organization categories do: [:cat | (aPattern match: cat)
  186.             ifTrue: [(organization listAtCategoryNamed: cat)
  187.                     do: 
  188.                         [:aSymbol | 
  189.                         aBlock value: (Smalltalk at: aSymbol).
  190.                         aBlock value: (Smalltalk at: aSymbol) class]]]! !
  191.  
  192. LauncherView initialize!
  193. LauncherView openLauncher!